home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / DB_CLIPP / 3032.ZIP / RLIB20.ZIP / DEMOPROC.PRG < prev    next >
Text File  |  1989-02-18  |  15KB  |  549 lines
  1. ******************************************************************************
  2. * THIS FILE CONTAINS THE PROCEDURES WHICH ACTUALLY DEMONSTRATE THE FUNCTIONS *
  3. ******************************************************************************
  4.  
  5.  
  6. *-----------------------------------------------------------------------------
  7. PROCEDURE d_atinsay
  8. mrow = 21
  9. mcol = 20
  10. mcolor = 'W+*/N   '
  11. mtext  = '           Testing: 1, 2, 3           '
  12. DO ClearTop
  13. @ 3,0,11,79 BOX double
  14. @ 5, 1 SAY 'Enter row,colum coordinates   ,'
  15. @ 5,29 GET mrow PICTURE '##' RANGE 0,24
  16. @ 5,32 GET mcol PICTURE '##' RANGE 0,79
  17. @ 6, 1 SAY 'Enter Clipper color string ' GET mcolor PICTURE "@!"
  18. @ 7, 1 SAY 'Enter the text to display  ' GET mtext  PICTURE "@K"
  19. SET CURSOR ON
  20. READ
  21. SET CURSOR OFF
  22. ATINSAY( mrow, mcol, mcolor, mtext )
  23. CENTER( 10, 'Press any key to continue...' )
  24. INKEY(10)
  25. RETURN
  26.  
  27.  
  28. *-----------------------------------------------------------------------------
  29. PROCEDURE d_boxask
  30. DO ClearTop
  31. SET CURSOR ON
  32. @ 3,0,11,79 BOX double
  33. @ 5,1 SAY 'Enter two lines of text to appear in BOXASK (up to 65 characters each)'
  34. @ 7,1 SAY 'Line #1: '
  35. mline1 = KEYINPUT( 65, .F., .T. )
  36. @ 8,1 SAY 'Line #2: '
  37. mline2 = KEYINPUT( 65, .F., .T. )
  38. answer = BOXASK( mline1, mline2, 'Now press any key...' )
  39. BOXASK( 'You pressed the ' + answer + ' key in response to BOXASK',;
  40.         'Press any key to continue...', 30 )
  41. SET CURSOR OFF
  42. RETURN
  43.  
  44.  
  45. *-----------------------------------------------------------------------------
  46. PROCEDURE d_bright
  47. DO ClearTop
  48. SET CURSOR ON
  49. mcolor = PAD(SETCOLOR(),20)
  50. @ 4,5,7,68 BOX double
  51. @ 5,12 SAY 'Enter a Clipper color string:' GET mcolor
  52. READ
  53. @ 6,12 SAY 'The BRIGHT() of this color is: ' + BRIGHT(mcolor)
  54. SET CURSOR OFF
  55. INKEY(10)
  56. RETURN
  57.  
  58.  
  59. *-----------------------------------------------------------------------------
  60. PROCEDURE d_center
  61. DO ClearTop
  62. SET CURSOR ON
  63. mstring = PAD('Greetings to all Clipper programmers!',78)
  64. @ 4,0,7,79 BOX double
  65. CENTER(5,'Enter a string to be centered')
  66. @ 6,1 GET mstring PICTURE "@K"
  67. READ
  68. @ 6,1 SAY SPACE(78)
  69. CENTER(6,ALLTRIM(mstring))
  70. SET CURSOR OFF
  71. INKEY(10)
  72. RETURN
  73.  
  74.  
  75. *-----------------------------------------------------------------------------
  76. PROCEDURE d_sayinbox
  77. DO ClearTop
  78. SET CURSOR ON
  79. @ 3,0,11,79 BOX double
  80. @ 5,1 SAY 'Enter three lines of text to appear in SAYINBOX (up to 65 characters each)'
  81. @ 7,1 SAY 'Line #1: '
  82. mline1 = KEYINPUT( 65, .F., .T. )
  83. @ 8,1 SAY 'Line #2: '
  84. mline2 = KEYINPUT( 65, .F., .T. )
  85. @ 9,1 SAY 'Line #3: '
  86. mline3 = KEYINPUT( 65, .F., .T. )
  87. SAYINBOX( mline1, mline2, mline3, 10 )
  88. SET CURSOR OFF
  89. RETURN
  90.  
  91.  
  92. *-----------------------------------------------------------------------------
  93. PROCEDURE d_filedate
  94. DO ClearTop
  95. SET CURSOR ON
  96. mfile = PAD(GETE('COMSPEC'),40)
  97. @ 4,0,7,79 BOX double
  98. CENTER(5,'Enter an existing filename:')
  99. @ 6,CENTER(mfile) GET mfile PICTURE "@!K"
  100. READ
  101. @ 6,1 SAY SPACE(78)
  102. mfile = ALLTRIM(mfile)
  103. CENTER(6, 'Last update date of &mfile is: ' + DTOC(FILEDATE(mfile)) )
  104. SET CURSOR OFF
  105. INKEY(10)
  106. RETURN
  107.  
  108.  
  109. *-----------------------------------------------------------------------------
  110. PROCEDURE d_files
  111. DO ClearTop
  112. SET CURSOR ON
  113. mfile1 = PAD('RLIB.LIB',60)
  114. mfile2 = PAD('DEMO.EXE',60)
  115. mfile3 = PAD('DEMO.PRG',60)
  116. @ 4,0,7,79 BOX double
  117. CENTER(5,"Enter files to test for existance:")
  118. @ 6, 2 SAY "#1:" GET mfile1 PICTURE "@!KS20"
  119. @ 6,28 SAY "#2:" GET mfile2 PICTURE "@!KS20"
  120. @ 6,54 SAY "#3:" GET mfile3 PICTURE "@!KS20"
  121. READ
  122. @ 6,1 SAY SPACE(78)
  123. mfile1 = ALLTRIM(mfile1)
  124. mfile2 = ALLTRIM(mfile2)
  125. mfile3 = ALLTRIM(mfile3)
  126. mdisplay = 'FILES("&mfile1", "&mfile2", "&mfile3") = ' +;
  127.             IF( FILES(mfile1, mfile2, mfile3), '.T.', '.F.' )
  128. CENTER(6,mdisplay)
  129. SET CURSOR OFF
  130. INKEY(10)
  131. RETURN
  132.  
  133.  
  134. *-----------------------------------------------------------------------------
  135. PROCEDURE d_filetime
  136. DO ClearTop
  137. SET CURSOR ON
  138. mfile = PAD(GETE('COMSPEC'),40)
  139. @ 4,0,7,79 BOX double
  140. CENTER(5,'Enter an existing filename:')
  141. @ 6,CENTER(mfile) GET mfile PICTURE "@!K"
  142. READ
  143. @ 6,1 SAY SPACE(78)
  144. mfile = ALLTRIM(mfile)
  145. CENTER(6, 'Last update time of &mfile is: ' + FILETIME(mfile) )
  146. SET CURSOR OFF
  147. INKEY(10)
  148. RETURN
  149.  
  150.  
  151. *-----------------------------------------------------------------------------
  152. PROCEDURE d_parent
  153. PRIVATE mdir
  154. DO ClearTop
  155. SET CURSOR ON
  156. mdir = PAD('C:\CLIPPER\LIBS\RLIB\SOURCE',40)
  157. @ 4,0,8,79 BOX double
  158. CENTER(5, 'Press ENTER or type in another directory name:')
  159. @ 6,CENTER(mdir) GET mdir PICTURE "@!K"
  160. READ
  161. @ 6,1 SAY SPACE(78)
  162. CENTER(6,ALLTRIM(mdir))
  163. CENTER(7,'The parent directory is ' + PARENT(mdir) )
  164. SET CURSOR OFF
  165. INKEY(10)
  166. RETURN
  167.  
  168.  
  169. *-----------------------------------------------------------------------------
  170. PROCEDURE d_pathto
  171. PRIVATE mfile, mpath
  172. DO ClearTop
  173. SET CURSOR ON
  174. mfile = "CLIPPER.EXE "
  175. @ 4,0,8,79 BOX double
  176. CENTER(5, 'Enter the name of a file which can be found through the DOS path')
  177. CENTER(6, '(Current DOS path is ' + GETE('PATH') + ')')
  178. @ 7,CENTER(mfile) GET mfile PICTURE "@!"
  179. READ
  180. mfile = ALLTRIM(mfile)
  181. mpath = PATHTO(mfile)
  182. IF EMPTY(mpath)
  183.    CENTER(7,'&mfile is not located in any directory in the DOS path!')
  184. ELSE
  185.    CENTER(7,'&mfile can be found in the &mpath directory')
  186. ENDIF
  187. SET CURSOR OFF
  188. INKEY(10)
  189. RETURN
  190.  
  191.  
  192. *-----------------------------------------------------------------------------
  193. PROCEDURE d_pickfile
  194. DO ClearTop
  195. @ 5,15,7,65 BOX double
  196. filespec = '*.*' + SPACE(60)
  197. @ 6,19 SAY 'Enter filespec:' GET filespec PICTURE '@!KS26'
  198. SET CURSOR ON
  199. READ
  200. SET CURSOR OFF
  201. @ 5,15,7,65 BOX single
  202. IF LASTKEY() <> 27
  203.    filename = PICKFILE( TRIM(filespec), 1, 0, 24, democolor, .T. )
  204.    IF .NOT. EMPTY(filename)
  205.       SAYINBOX('You selected &filename',5)
  206.    ENDIF
  207. ENDIF
  208. RETURN
  209.  
  210.  
  211. *-----------------------------------------------------------------------------
  212. PROCEDURE d_decrypted
  213. PRIVATE mstring, estring, dstring
  214. DO ClearTop
  215. SET CURSOR ON
  216. mstring = SPACE(35)
  217. @ 4,0,8,79 BOX double
  218. @ 5,6 SAY 'Enter a string to be encrypted:' GET mstring
  219. READ
  220. estring = ENCRYPTED(ALLTRIM(mstring))
  221. CENTER(6,'Encrypted version is: &estring')
  222. dstring = DECRYPTED(estring)
  223. CENTER(7,'Decrypted version is: &dstring')
  224. SET CURSOR OFF
  225. INKEY(10)
  226. RETURN
  227.  
  228.  
  229. *-----------------------------------------------------------------------------
  230. PROCEDURE d_encrypted
  231. PRIVATE mstring, estring
  232. DO ClearTop
  233. SET CURSOR ON
  234. mstring = SPACE(35)
  235. @ 4,0,7,79 BOX double
  236. @ 5,6 SAY 'Enter a string to be encrypted:' GET mstring
  237. READ
  238. estring = ENCRYPTED(ALLTRIM(mstring))
  239. CENTER(6,'Encrypted version is: &estring')
  240. SET CURSOR OFF
  241. INKEY(10)
  242. RETURN
  243.  
  244.  
  245. *-----------------------------------------------------------------------------
  246. PROCEDURE d_getparm
  247. PRIVATE mstring, mnumber, mparm
  248. DO ClearTop
  249. SET CURSOR ON
  250. mstring = 'Red, Orange, Yellow, Green, Blue, Indigo, Violet'
  251. @ 4,0,9,79 BOX double
  252. CENTER(5,'Enter a string with sections separated by commas')
  253. @ 6,CENTER(mstring) GET mstring PICTURE '@K'
  254. READ
  255. mnumber = 4
  256. @ 7,25 SAY 'Enter parameter to retrieve:' GET mnumber PICTURE '#'
  257. READ
  258. mparm = GETPARM(mnumber,mstring)
  259. CENTER(8, 'Parameter #' + STR(mnumber,1,0) + ' is: &mparm')
  260. SET CURSOR OFF
  261. INKEY(10)
  262. RETURN
  263.  
  264.  
  265. *-----------------------------------------------------------------------------
  266. PROCEDURE d_keyinput
  267. PRIVATE length, upcase, echoon, mstring
  268. length = 60
  269. upcase = .F.
  270. echoon = .T.
  271. DO ClearTop
  272. @ 3,0,11,79 BOX double
  273. @ 4,2 SAY 'Enter maximum allowed key input length: ' GET length PICTURE '###'
  274. @ 5,2 SAY 'Force characters into upper case? (Y/N):' GET upcase PICTURE 'Y'
  275. @ 6,2 SAY 'Echo characters onto the screen? (Y/N): ' GET echoon PICTURE 'Y'
  276. SET CURSOR ON
  277. READ
  278. @ 8,1 SAY 'Start typing:'
  279. mstring = KEYINPUT(length,upcase,echoon)
  280. @ 10,1 SAY 'You entered: ' + mstring
  281. SET CURSOR OFF
  282. INKEY(10)
  283. RETURN
  284.  
  285.  
  286. *-----------------------------------------------------------------------------
  287. PROCEDURE d_namesplit
  288. PRIVATE mname, sname
  289. DO ClearTop
  290. SET CURSOR ON
  291. mname = PAD('Elmer Q. Fudd',35)
  292. @ 4,0,7,79 BOX double
  293. @ 5,6 SAY 'Enter a name to be parsed (split):' GET mname
  294. READ
  295. sname = NAMESPLIT(mname)
  296. CENTER(6,'NAMESPLIT() version is: &sname')
  297. SET CURSOR OFF
  298. INKEY(10)
  299. RETURN
  300.  
  301.  
  302. *-----------------------------------------------------------------------------
  303. PROCEDURE d_rjustify
  304. PRIVATE mstring
  305. DO ClearTop
  306. SET CURSOR ON
  307. mstring = SPACE(40)
  308. @ 4,0,7,79 BOX double
  309. @ 5,3 SAY 'Enter text to be right justified:' GET mstring
  310. READ
  311. @ 6,39 SAY RJUSTIFY(mstring)
  312. SET CURSOR OFF
  313. INKEY(10)
  314. RETURN
  315.  
  316.  
  317. *-----------------------------------------------------------------------------
  318. PROCEDURE d_changed
  319. DO NoDemo
  320. RETURN
  321.  
  322.  
  323. *-----------------------------------------------------------------------------
  324. PROCEDURE d_closearea
  325. DO NoDemo
  326. RETURN
  327.  
  328.  
  329. *-----------------------------------------------------------------------------
  330. PROCEDURE d_forget
  331. DO NoDemo
  332. RETURN
  333.  
  334.  
  335. *-----------------------------------------------------------------------------
  336. PROCEDURE d_markrec
  337.  
  338. GO TOP
  339. DO ClearTop
  340.  
  341. @ 4,4,8,46 BOX single
  342. @ 5,6 SAY 'Press the  keys to choose a function.'
  343. @ 6,6 SAY 'Mark by pressing the F9 key, and finish'
  344. @ 7,6 SAY 'by pressing the ENTER key.             '
  345.  
  346. @ 1,60,12,79 BOX double
  347. marked = MARKREC( 2, 61, 11, 78, "' '+udf_name", -8, "udf_name" )
  348. @ 1,60,12,79 BOX single
  349.  
  350. IF .NOT. EMPTY(marked)
  351.    SCROLL(4,4,8,46,0)
  352.    @ 13,0 CLEAR
  353.    mrow = 3
  354.    @ 3,0 SAY 'You marked: '
  355.    DO WHILE .NOT. EMPTY(marked)
  356.       @ mrow,12 SAY SUBSTR( marked, 1, AT(",",marked)-1 )
  357.       marked = SUBSTR( marked, AT(",",marked)+1 )
  358.       mrow = mrow + 1
  359.       INKEY(1)
  360.    ENDDO
  361.    ?
  362.    ? 'Press any key to continue...'
  363.    INKEY(60)
  364. ENDIF
  365. RETURN
  366.  
  367.  
  368. *-----------------------------------------------------------------------------
  369. PROCEDURE d_memorize
  370. DO NoDemo
  371. RETURN
  372.  
  373.  
  374. *-----------------------------------------------------------------------------
  375. PROCEDURE d_mreplace
  376. DO NoDemo
  377. RETURN
  378.  
  379.  
  380. *-----------------------------------------------------------------------------
  381. PROCEDURE d_pickrec
  382. PRIVATE incolor
  383. INKEY(5)              && give them 5 more seconds to see write up on PICKREC()
  384. GO TOP
  385. mrow = 0
  386. DO ClearTop
  387. incolor = SETCOLOR()
  388. DO WHILE .T.
  389.    @ 1,60,12,79 BOX double
  390.    mrow = PICKREC( 2, 61, 11, 78, "' '+udf_name", "DISPSYNTAX", dummy, mrow )
  391.    @ 1,60,12,79 BOX single
  392.    DO CASE
  393.       CASE mrow = 0
  394.          EXIT
  395.       CASE LASTKEY() = 13                            && Enter key
  396.          IF edit                                     && allow edits if variable set to True
  397.             @ 13,0,24,79 BOX double
  398.             SET COLOR TO (syntaxcolor)
  399.             SET CURSOR ON
  400.             REPLACE Descrip WITH MEMOEDIT( Descrip, 14, 1, 23, 78, .T. )
  401.             SET CURSOR OFF
  402.             SET COLOR TO (incolor)
  403.             @ 13,0,24,79 BOX single
  404.          ELSE
  405.             EXIT
  406.          ENDIF
  407.    ENDCASE
  408. ENDDO
  409. RETURN
  410.  
  411.  
  412. PROCEDURE dispsyntax
  413. *-- don't update the display if they are stopming on the arrow keys
  414. IF NEXTKEY() = 0
  415.    SET COLOR TO (syntaxcolor)
  416.    MEMOEDIT( Descrip, 14, 1, 23, 78, .F., .F. )
  417.    SET COLOR TO (incolor)
  418. ENDIF
  419. RETURN
  420.  
  421.  
  422. *-----------------------------------------------------------------------------
  423. PROCEDURE d_alphadate
  424. PRIVATE mdate
  425. DO ClearTop
  426. SET CURSOR ON
  427. mdate = DATE()
  428. @ 4,0,7,79 BOX double
  429. @ 5,6 SAY 'Enter date to be displayed as text:' GET mdate
  430. READ
  431. CENTER(6,ALPHADATE(mdate))
  432. SET CURSOR OFF
  433. INKEY(10)
  434. RETURN
  435.  
  436.  
  437. *-----------------------------------------------------------------------------
  438. PROCEDURE d_beep
  439. PRIVATE mnumber
  440. DO ClearTop
  441. SET CURSOR ON
  442. mnumber = 2
  443. @ 4,0,7,79 BOX double
  444. @ 5,6 SAY 'How many times do you want to ring the bell?' GET mnumber PICTURE '#'
  445. READ
  446. CENTER( 6, 'This is an example of BEEP(' + STR(mnumber,1,0) + ')')
  447. SET CURSOR OFF
  448. BEEP(mnumber)
  449. INKEY(10)
  450. RETURN
  451.  
  452.  
  453. *-----------------------------------------------------------------------------
  454. PROCEDURE d_ntxkeyval
  455. DO NoDemo
  456. RETURN
  457.  
  458.  
  459. *-----------------------------------------------------------------------------
  460. PROCEDURE d_str2date
  461. PRIVATE datestring
  462. DO ClearTop
  463. SET CURSOR ON
  464. datestring = PAD( ALPHADATE(DATE()),30 )
  465. @ 4,0,7,79 BOX double
  466. @ 5,6 SAY 'Enter date string to be converted:' GET datestring
  467. READ
  468. CENTER( 6, "The date is: " + DTOC(STR2DATE(datestring)) )
  469. SET CURSOR OFF
  470. INKEY(10)
  471. RETURN
  472.  
  473.  
  474. *-----------------------------------------------------------------------------
  475. PROCEDURE d_multimenu
  476. SET COLOR TO (multicolors[1])
  477. SCROLL(2,10,6,70,0)
  478. @ 2,10,6,70 BOX single
  479. CENTER(4,'Loading directory for MULTIMENU demostration')
  480.  
  481. *-- get a directory of all files
  482. num = ADIR("*.*")
  483. DECLARE files[num], sizes[num], dates[num], times[num], fileinfo[num]
  484. ADIR( "*.*", files, sizes, dates, times )
  485.  
  486. FOR x = 1 TO num
  487.    *-- now make each file name 12 spaces wide
  488.    files[x] = PAD(files[x],12)
  489.    *-- and build file description for each
  490.    fileinfo[x] = 'Date: ' + DTOC(dates[x]) + '    ' +;
  491.                  'Time: ' + times[x] + '    ' +;
  492.                  'Size: ' + TRANSFORM( sizes[x], '###,###' )
  493. NEXT x
  494.  
  495. *-- now present these files in a single line box with four
  496. *-- columns across and descriptions on the line below the box
  497.  
  498. DO ClearTop
  499.  
  500. @ 1,0,10,79 BOX single
  501. *-- the zero makes UDF calc column number dynamically
  502. filenum = MULTIMENU( 2, 1, 9, 78, files, 4, fileinfo, 11, multicolors )
  503. RETURN
  504.  
  505.  
  506. *-----------------------------------------------------------------------------
  507. * Procedure: ShowSyntax
  508. * Notes....: Procedure to look up function in database and display the memo
  509. *            contents in a 12 line window at the bottom of the screen.
  510. *-----------------------------------------------------------------------------
  511. PROCEDURE ShowSyntax
  512. PRIVATE incolor
  513. incolor = SETCOLOR(syntaxcolor)
  514. @ 0,0 SAY UPPER(SUBSTR(demoproc,3)) + '()'
  515. SCROLL(13,0,23,79,0)
  516. @ 13,0,24,79 BOX single
  517. SEEK UPPER(SUBSTR(demoproc,3))
  518. MEMOEDIT( Descrip, 14, 1, 23, 78, .F., .F. )
  519. SETCOLOR(incolor)
  520. INKEY(showtime)
  521. RETURN
  522.  
  523.  
  524. *-----------------------------------------------------------------------------
  525. * Procedure: ClearTop
  526. * Notes....: Central procedure for clearing the top window in preparation
  527. *            for the particular function demonstration.
  528. *-----------------------------------------------------------------------------
  529. PROCEDURE ClearTop
  530. SCROLL(1,0,12,79,0)
  531. RETURN
  532.  
  533.  
  534. *-----------------------------------------------------------------------------
  535. * Procedure: NoDemo
  536. * Notes....: Sub-procedure called by several of the demo procedures.  These
  537. *            functions by their very nature are difficult to demonstrate or
  538. *            any demonstration would not be very meaningful.
  539. *-----------------------------------------------------------------------------
  540. PROCEDURE NoDemo
  541. DO ClearTop
  542. @ 2,6,10,72 BOX single
  543. @ 4,8 SAY 'This function is difficult to demonstrate, as any demonstration'
  544. @ 5,8 SAY 'would just be a reiteration of the function syntax shown below.'
  545. @ 6,8 SAY 'See the RLIB documentation for more information and examples.'
  546. CENTER(8,'Press any key to continue...')
  547. INKEY(60)
  548. RETURN
  549.